home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / transm.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  17.1 KB  |  588 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  9. ;;;                Macros for TRANSL source compilation.                 ;;;
  10. ;;;       (c) Copyright 1980 Massachusetts Institute of Technology       ;;;
  11. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  12.  
  13. (in-package "MAXIMA")
  14. (macsyma-module transm macro)
  15. (load-macsyma-macros procs)
  16. (load-macsyma-macros-at-runtime 'procs)
  17.  
  18. (DEFVAR TRANSL-MODULES NIL)
  19.  
  20. ;;; Simple but effective single-level module definitions
  21. ;;; and utilities which work through property lists.
  22. ;;; Information has to be in various places:
  23. ;;; [1] Compile-time of the TRANSLATOR itself.
  24. ;;; [2] Runtime of the translator.
  25. ;;; [3] Translate-time of user-code
  26. ;;; [4] Compile-time of user-code.
  27. ;;; [5] Runtime of user-code.
  28. ;;; [6] "Utilities" or documentation-time of user-code.
  29.  
  30. ;;; -GJC 
  31.  
  32. ;;; Note: Much of the functionality here was in use before macsyma as
  33. ;;; a whole got such mechanisms, however we must admit that the macsyma
  34. ;;; user-level (and non-modular global only) INFOLISTS of FUNCTIONS and VALUES,
  35. ;;; inspired this, motivated by my characteristic lazyness.
  36.  
  37. (DEFMACRO ENTERQ (THING LIST)
  38.   ;; should be a DEF-ALTERANT
  39.   `(OR (MEMQ ,THING ,LIST)
  40.        (SETF ,LIST (CONS ,THING ,LIST))))
  41.  
  42. (DEFMACRO DEF-TRANSL-MODULE (NAME &REST PROPERTIES)
  43.   `(PROGN
  44.     (ENTerQ ',NAME TRANSL-MODULES)
  45.     ,@(MAPCAR #'(LAMBDA (P)
  46.           `(DEFPROP ,NAME
  47.              ,(IF (ATOM P) T (CDR P))
  48.              ,(IF (ATOM P) P (CAR P))))
  49.           PROPERTIES)))
  50.  
  51. (DEF-TRANSL-MODULE TRANSS TTIME-AUTO)
  52. (DEF-TRANSL-MODULE TRANSL TTIME-AUTO (FIRST-LOAD TRDATA DCL))
  53. (DEF-TRANSL-MODULE TRUTIL TTIME-AUTO)
  54. (DEF-TRANSL-MODULE TRANS1 TTIME-AUTO)
  55. (DEF-TRANSL-MODULE TRANS2 TTIME-AUTO)
  56. (DEF-TRANSL-MODULE TRANS3 TTIME-AUTO)
  57. (DEF-TRANSL-MODULE TRANS4 TTIME-AUTO)
  58. (DEF-TRANSL-MODULE TRANS5 TTIME-AUTO)
  59. (DEF-TRANSL-MODULE TRANSF TTIME-AUTO)
  60. (DEF-TRANSL-MODULE TROPER TTIME-AUTO)
  61. (DEF-TRANSL-MODULE TRPRED TTIME-AUTO)
  62.  
  63. (DEF-TRANSL-MODULE MTAGS TTIME-AUTO)
  64. (DEF-TRANSL-MODULE MDEFUN)
  65. (DEF-TRANSL-MODULE TRANSQ)
  66. (DEF-TRANSL-MODULE FCALL  NO-LOAD-AUTO)
  67. (DEF-TRANSL-MODULE ACALL NO-LOAD-AUTO)
  68. (DEF-TRANSL-MODULE TRDATA   NO-LOAD-AUTO)
  69. (DEF-TRANSL-MODULE MCOMPI TTIME-AUTO)
  70.  
  71. (DEF-TRANSL-MODULE DCL pseudo) ; more data
  72. (DEFPROP DCL MAXDOC FASL-DIR)
  73.  
  74. (DEF-TRANSL-MODULE TRMODE TTIME-AUTO
  75.   NO-LOAD-AUTO
  76.   ;; Temporary hack, TRANSL AUTOLOADs should be
  77.   ;; in a different file from functional autoloads.
  78.   )
  79.  
  80. (DEF-TRANSL-MODULE TRHOOK HYPER)
  81. (DEF-TRANSL-MODULE TRANSL-AUTOLOAD PSEUDO)
  82.  
  83. (eval-when (eval compile load)
  84.   (LOAD-MACSYMA-MACROS PROCS))
  85. #+ITS
  86. (DEFUN TR-FASL-FILE-NAME (FOO)
  87.   (NAMESTRING `((dsk  ,(get! foo 'fasl-dir)) ,foo fasl)))
  88.  
  89. #+Multics
  90. (defun tr-fasl-file-name (foo)
  91.   (NAMESTRING `,(executable-dir foo)))
  92.  
  93. #+ITS
  94. (defvar transl-autoload-oldio-name "DSK:MACSYM;TRANSL AUTOLO")
  95.  
  96. #+Multics
  97. (defvar transl-autoload-oldio-name (NAMESTRING (executable-dir 'transl/.autoload)))
  98.  
  99. (DEFVAR MODULE-STACK NIL)
  100.  
  101. (DEFMACRO TRANSL-MODULE (NAME)
  102.   (IF (NOT (MEMQ NAME TRANSL-MODULES))
  103.       (MAXIMA-ERROR "Not a TRANSL-MODULE, see LIBMAX;TRANSM >"))
  104.   #+PDP10
  105.   (PROGN (PUSH NAME MODULE-STACK)
  106.      (PUSH '(EVAL-WHEN (COMPILE EVAL)
  107.                (TRANSL-MODULE-DO-IT)
  108.                (POP MODULE-STACK))
  109.            EOF-COMPILE-QUEUE)
  110.      (PUTPROP NAME NIL 'FUNCTIONS)
  111.      (PUTPROP NAME NIL 'TR-PROPS)
  112.      (PUTPROP NAME NIL 'VARIABLES)
  113.      (DO ((L TRANSL-MODULES (CDR L)))
  114.          ((NULL L))
  115.        (IF (EQ (CAR L) NAME) NIL
  116.            (LOAD-MODULE-INFO (CAR L))))
  117.      )
  118.   #+PDP10
  119.   `(PROGN 'COMPILE
  120.       (DEFPROP ,NAME
  121.         ,(CADDR (NAMELIST (TRUENAME INFILE)))
  122.         VERSION)
  123.       (PROGN
  124.         ,(IF (NOT (GET NAME 'NO-LOAD-AUTO))
  125.          `(OR (GET 'TRANSL-AUTOLOAD 'VERSION)
  126.               ($LOAD ',transl-autoload-oldio-name)))
  127.         ,@(MAPCAR #'(LAMBDA (U)
  128.               `(OR (GET ',U 'VERSION)
  129.                    ($LOAD
  130.                 ',(TR-FASL-FILE-NAME U))))
  131.               (GET NAME 'FIRST-LOAD))))
  132.   #-PDP10
  133.   '(COMMENT THERE ARE REASONABLE THINGS TO DO HERE)
  134.   )
  135.  
  136. #+PDP10
  137.  
  138. (DEFUN LAMBDA-TYPE (ARGLIST)
  139.   (COND ((NULL ARGLIST)
  140.      '(*EXPR . (NIL . 0)))
  141.     ((ATOM ARGLIST)
  142.      '(*LEXPR . NIL))
  143.     (T
  144.      ;; (FOO BAR &OPTIONAL ... &REST L &AUX)
  145.      ;; #O776 is the MAX MAX.
  146.      (DO ((MIN 0)
  147.           (MAX 0)
  148.           (OPTIONAL NIL)
  149.           (L ARGLIST (CDR L)))
  150.          ((NULL L)
  151.           (IF (= MIN MAX)
  152.           `(*EXPR . (NIL . ,MIN))
  153.           `(*LEXPR . (,MIN . ,MAX))))
  154.        (CASE (CAR L)
  155.          ((&REST)
  156.           (SETQ MAX #o776)
  157.           (SETQ L NIL))
  158.          ((&OPTIONAL)
  159.           (SETQ OPTIONAL T))
  160.          ((&AUX)
  161.           (SETQ L NIL))
  162.          (t
  163.           (IF (AND (SYMBOLP (CAR L))
  164.                (= #\& (GETCHARN (CAR L) 1)))
  165.           (RETURN
  166.            (LAMBDA-TYPE
  167.             (MAXIMA-ERROR (LIST "arglist has unknown &keword" (CAR L))
  168.                ARGLIST 'WRNG-TYPE-ARG))))
  169.           (OR OPTIONAL (SETQ MIN (f1+ MIN)))
  170.           (SETQ MAX (f1+ MAX))))))))
  171.  
  172. (def-def-property translate (form))
  173.  
  174. #+cl
  175. (defmacro def%tr (name lambda-list &body body &aux definition)
  176.   (setq definition
  177.     (COND ((AND (NULL BODY) (SYMBOLP LAMBDA-LIST))
  178.            `(DEF-SAME%TR ,NAME ,LAMBDA-LIST))
  179.           (T
  180.            #+PDP10
  181.            (ENTERQ NAME (GET (CAR MODULE-STACK) 'TR-PROPS))
  182.            `(defun-prop (,name translate) ,lambda-list ,@ body))))
  183.   `(eval-when (compile eval load)
  184.       #+lispm(record-source-file-name ',name 'def%tr)
  185.       ,definition))
  186.  
  187.  
  188. #-cl
  189. (DEFMACRO DEF%TR (NAME LAMBDA-LIST &REST BODY)
  190.   (COND ((AND (NULL BODY) (SYMBOLP LAMBDA-LIST))
  191.      `(DEF-SAME%TR ,NAME ,LAMBDA-LIST))
  192.     (T
  193.      #+PDP10
  194.      (ENTERQ NAME (GET (CAR MODULE-STACK) 'TR-PROPS))
  195.      `(def-translate-property ,NAME
  196.         ,LAMBDA-LIST ,@BODY))))
  197.  
  198. (DEFMACRO DEF-SAME%TR (NAME SAME-AS)
  199.   ;; right now MUST be used in the SAME file.
  200.   #+PDP10
  201.   (ENTERQ NAME (GET (CAR MODULE-STACK) 'TR-PROPS))
  202.   `(PUTPROP ',NAME
  203.         (OR (GET ',SAME-AS 'TRANSLATE)
  204.         (MAXIMA-ERROR '|No TRANSLATE property to alias.| ',SAME-AS))
  205.         'TRANSLATE))
  206.  
  207. (DEFMACRO DEF%TR-INHERIT (FROM &REST OTHERS)
  208.   #+PDP10
  209.   (mapc #'(lambda (name)
  210.         (enterq name (get (car module-stack) 'tr-props)))
  211.     others)
  212.   `(LET ((TR-PROP (OR (GET ',FROM 'TRANSLATE)
  213.               (MAXIMA-ERROR '|No TRANSLATE property to alias.| ',FROM))))
  214.      (MAPC #'(LAMBDA (NAME) (PUTPROP NAME TR-PROP 'TRANSLATE))
  215.        ',OTHERS)))
  216.  
  217. #+PDP10
  218. (DEFUN PUT-LAMBDA-TYPE (NAME ARGL)
  219.        (LET ((LAMBDA-TYPE (LAMBDA-TYPE ARGL)))
  220.         (PUTPROP NAME T (CAR LAMBDA-TYPE))
  221.         (ARGS NAME (CDR LAMBDA-TYPE))))
  222.  
  223.  
  224. (DEFMACRO DEFTRFUN (NAME ARGL &REST BODY)
  225.   #+PDP10
  226.   (PROGN (ENTERQ NAME (GET (CAR MODULE-STACK) 'FUNCTIONS))
  227.      (PUT-LAMBDA-TYPE NAME ARGL))
  228.   `(DEFUN ,NAME ,ARGL ,@BODY))
  229.  
  230. (DEFMACRO DEFTRVAR (NAME VALUE &REST IGNORE-DOC) IGNORE-DOC
  231.   ;; to be used to put the simple default value in
  232.   ;; the autoload file. Should be generalized to include
  233.   ;; BINDING methods.
  234.   #+PDP10
  235.   (PROGN (ENTERQ NAME (GET (CAR MODULE-STACK) 'VARIABLES))
  236.      (PUTPROP NAME (IF (FBOUNDP 'MACRO-EXPAND)
  237.                (MACRO-EXPAND VALUE)
  238.                VALUE)
  239.           'VALUE))
  240.   `(DEFVAR ,NAME ,VALUE))
  241.  
  242. ;#+PDP10
  243. ;(PROGN 'COMPILE
  244.  
  245. ;(defun get! (a b) (or (get a b) (get! (MAXIMA-ERROR (list "undefined" b "property")
  246. ;                         a 'wrng-type-arg)
  247. ;                      b)))
  248.  
  249. ;(defun print-defprop (symbol prop stream)
  250. ;       (print `(defprop ,symbol ,(get symbol prop) ,prop) stream))
  251.  
  252. ;(defun save-module-info (module stream)
  253. ;  (putprop module `(,(status uname) ,(status dow) ,(status date))
  254. ;       'last-compiled)
  255. ;  (print-defprop module 'last-compiled stream)
  256. ;  (print-defprop module 'functions stream)
  257. ;  (print-defprop module 'variables stream)
  258. ;  (print-defprop module 'tr-props stream)
  259. ;  (DO ((VARIABLES (get module 'VARIABLES) (CDR VARIABLES)))
  260. ;      ((NULL VARIABLES))
  261. ;    (print-defprop (car variables) 'value stream)
  262. ;    ;; *NB*
  263. ;    ;; this depends on knowing about the internal workings
  264. ;    ;; of the maclisp compiler!!!!
  265. ;    (print `(defprop ,(car variables)
  266. ;          (special ,(car variables))
  267. ;          special)
  268. ;       stream)
  269. ;    )
  270. ;  (DO ((FUNCTIONS (GET MODULE 'FUNCTIONS) (CDR FUNCTIONS)))
  271. ;      ((NULL FUNCTIONS))
  272. ;    ;; *NB* depends on maclisp compiler.
  273. ;    (LET ((X (GETL (CAR FUNCTIONS) '(*LEXPR *EXPR))))
  274. ;      (IF X
  275. ;      (PRINT-DEFPROP (CAR FUNCTIONS) (CAR X) STREAM)))
  276. ;    (LET ((X (ARGS (CAR FUNCTIONS))))
  277. ;      (IF X
  278. ;      (PRINT `(ARGS ',(CAR FUNCTIONS) ',X) STREAM)))))
  279.  
  280. ;(defun save-enable-module-info (module stream)
  281. ;  ;; this outputs stuff to be executed in the context
  282. ;  ;; of RUNTIME of the modules, using information gotten
  283. ;  ;; by the SAVE done by the above function.
  284. ;  (print `(defprop ,module ,(tr-fasl-file-name module) fasload) stream)
  285. ;  ;; FASLOAD property lets us share the TR-FASL-FILE-NAME
  286. ;  ;; amoung the various autoload properties.
  287. ;  (print `(map1-put-if-nil ',(get module 'functions)
  288. ;               (get ',module 'fasload)
  289. ;               'autoload)
  290. ;     stream)
  291. ;  (print `(map1-put-if-nil ',(get module 'tr-props)
  292. ;               (get ',module 'fasload)
  293. ;               'autoload-translate)
  294. ;     stream)
  295. ;  (print `(map1-put-if-nil ',(get module 'tr-props)
  296. ;               (or (get 'autoload-translate 'subr)
  297. ;                   (MAXIMA-ERROR 'autoload-translate 'subr
  298. ;                      'fail-act))
  299. ;               'translate)
  300. ;     stream)
  301. ;  (do ((variables (get module 'variables) (cdr variables)))
  302. ;      ((null variables))
  303. ;    (print `(or (boundp ',(car variables))
  304. ;        (setq ,(car variables) ,(get (car variables) 'value)))
  305. ;       stream)))
  306.  
  307. ;(eval-when (compile eval)
  308. ;       (or (get 'iota 'macro) (load '|liblsp;iota fasl|)))
  309.  
  310. ;(DEFUN TRANSL-MODULE-DO-IT (&AUX (*print-base* 10.) (*NOPOINT NIL))
  311. ;       (let ((module (CAR MODULE-STACK)))
  312. ;        (cond ((AND (GET module 'ttime-auto)
  313. ;            (macsyma-compilation-p))
  314. ;           (iota ((f `((dsk ,(get! module 'dir))
  315. ;                   ,module _auto_) 'out))
  316. ;             (and ttynotes (format tyo "~&;MODULE : ~A~%" MODULE))
  317. ;             (save-module-info module f)
  318. ;             (renamef f "* AUTOLO"))
  319. ;           (INSTALL-TRANSL-AUTOLOADS)))))
  320.  
  321. ;(defun load-module-info (module)
  322. ;       (IF (AND (GET MODULE 'TTIME-AUTO)
  323. ;        ;; Assume we are the only MCL compiling
  324. ;        ;; a transl module at this time.
  325. ;        (NOT (GET MODULE 'LAST-COMPILED)))
  326. ;       (LET ((FILE `((dsk ,(get! module 'dir))
  327. ;             ,module autolo)))
  328. ;        (COND ((PROBE-FILE FILE)
  329. ;               (AND TTYNOTES
  330. ;                (FORMAT TYO "~&;Loading ~A info~%"
  331. ;                    file))
  332. ;               (LOAD FILE))
  333. ;              (T
  334. ;               (AND TTYNOTES
  335. ;                (FORMAT TYO "~&; ~A NOT FOUND~%"
  336. ;                    file)))))))
  337.  
  338. ;(defvar autoload-install-file "dsk:macsyma;transl autoload")
  339.  
  340. ;(DEFUN UNAME-TIMEDATE (FORMAT-STREAM)
  341. ;       (LET (((YEAR MONTH DAY) (STATUS DATE))
  342. ;         ((HOUR MINUTE SECOND) (STATUS DAYTIME)))
  343. ;        (FORMAT FORMAT-STREAM
  344. ;            "by ~A on ~A, ~
  345. ;           ~[January~;February~;March~;April~;May~;June~;July~;August~
  346. ;           ~;September~;October~;November~;December~] ~
  347. ;           ~D, 19~D, at ~D:~2,'0D:~2,'0D"
  348. ;            (status uname)
  349. ;            (status dow)
  350. ;            (f1- month) day year
  351. ;            hour minute second)))
  352.  
  353. ;(defun install-transl-autoloads ()
  354. ;       (MAPC #'LOAD-MODULE-INFO TRANSL-MODULES)
  355. ;       (iota ((f (mergef "* _TEMP"
  356. ;             autoload-install-file)
  357. ;         '(out ascii)))
  358. ;         (PRINT `(progn
  359. ;              (DEFPROP TRANSL-AUTOLOAD ,(Uname-timedate nil) VERSION)
  360. ;              (OR (GET 'TRANSL-AUTOLOAD 'SUBR)
  361. ;              (load '((dsk macsym)trhook fasl)))
  362. ;              (setq transl-modules
  363. ;                ',transl-modules))
  364. ;            F)
  365. ;         (DO ((MODULES TRANSL-MODULES (CDR MODULES)))
  366. ;         ((NULL MODULES)
  367. ;          (renamef f autoload-install-file))
  368. ;         (and (get (car modules) 'ttime-auto)
  369. ;              (save-enable-module-info (car modules) f)))))
  370.  
  371. ;(defun tr-tagS ()
  372. ;  ;; trivial convenience utility.
  373. ;  (iota ((f `((dsk ,(get 'transl 'dir)) transl ntags) 'out))
  374. ;    (do ((l transl-modules (cdr l)))
  375. ;    ((null l)
  376. ;     (close f)
  377. ;     (valret
  378. ;      (symbolconc '|:TAGS | (NAMESTRING F) '|
  379. ; |)))
  380. ;      (or (get (car l) 'pseudo)
  381. ;      (format f "DSK:~A;~A >~%,LISP~%~%"
  382. ;          (get! (car l) 'dir) (car l))))))
  383.  
  384. ;;;; end of #+PDP10 I/O code.
  385.  
  386. ;)
  387.  
  388. ;;; in PDP-10 maclisp OP is a subr-pointer.
  389. ;;; system-dependance macro-fied away in PROCS.
  390.  
  391. (DEFMACRO TPROP-CALL (OP FORM)
  392.   `(subr-call ,op ,form))
  393.  
  394. (DEFMACRO DEF-AUTOLOAD-TRANSLATE (&REST FUNS)
  395.   #+PDP10
  396.   `(LET ((A-SUBR (OR (GET 'AUTOLOAD-TRANSLATE 'SUBR)
  397.              (MAXIMA-ERROR 'LOSE 'AUTOLOAD-TRANSLATE 'FAIL-ACT))))
  398.      (mapc #'(lambda (u)
  399.           (or (get u 'translate)
  400.           (putprop u A-SUBR 'TRANSLATE)))
  401.        ',FUNS))
  402.   #-PDP10
  403.   `(COMMENT *AUTOLOADING?* ,@FUNS))
  404.  
  405.  
  406. ;;; declarations for the TRANSL PACKAGE.
  407.  
  408. (declare-top 
  409.   (SPECIAL *TRANSL-SOURCES*)
  410.   ;; The warning an error subsystem.
  411.   (SPECIAL TR-ABORT                ; set this T if you want to abort.
  412.        *TRANSLATION-MSGS-FILES*)        ; the stream to print messages to.
  413.   (*LEXPR WARN-UNDEDECLARED
  414.       TR-NARGS-CHECK
  415.       WARN-MEVAL
  416.       WARN-MODE
  417.       WARN-FEXPR
  418.       TELL)
  419.   
  420.   (*LEXPR PUMP-STREAM                ; file hacking
  421.       )
  422.   
  423.   ;; State variables.
  424.   
  425.   (SPECIAL PRE-TRANSL-FORMS*            ; push onto this, gets output first into the
  426.                         ; transl file.
  427.        *WARNED-UN-DECLARED-VARS*
  428.        *WARNED-FEXPRS* 
  429.        *WARNED-MODE-VARS*
  430.        *WARNED-UNDEFINED-VARS*
  431.        WARNED-UNDEFINED-VARIABLES
  432.        TR-ABORT
  433.        TRANSL-FILE
  434.        *IN-COMPFILE*
  435.        *IN-TRANSLATE-FILE*
  436.        *IN-TRANSLATE*
  437.        *PRE-TRANSL-FORMS* 
  438.        *NEW-AUTOLOAD-ENTRIES*        ; new entries created by TRANSL. 
  439.        *UNTRANSLATED-FUNCTIONS-CALLED*
  440.        )
  441.   
  442.   ;; General entry points.
  443.   
  444.   (*EXPR TRANSLATE
  445.      ;; Takes a macsyma form, returns a form
  446.      ;; such that the CAR is the MODE and the
  447.      ;; CDR is the equivalent lisp form.
  448.      ;; For the meaning of the second argument to TRANSLATE
  449.      ;; see the code. When calling TRANSLATE from outside of
  450.      ;; itself, the second arg is always left out.
  451.      TR-ARGS                ; mapcar of translate, strips off the modes.
  452.      DTRANSLATE                ; CDR TRANSLATE
  453.      CALL-AND-SIMP                ; (MODE F ARGL) generates `(,F ,@ARGL)
  454.      ;; sticks on the mode and a SIMPLIFY if needed.
  455.      ARRAY-MODE
  456.      FUNCTION-MODE
  457.      VALUE-MODE
  458.      TBIND                    ; For META binding of variables.
  459.      TUNBIND                ; unbind.
  460.      TUNBINDS                ; a list.
  461.      TBOUNDP                ; is the variable lexicaly bound?
  462.      TEVAL                    ; get the var replacement. Now this is always
  463.      ;; the same as the var itself. BUT it could be use
  464.      ;; to do internal-mode stuff.
  465.      
  466.      PUSH-PRE-TRANSL-FORM
  467.      
  468.      )
  469.   (*LEXPR TR-LOCAL-EXP
  470.       ;; conses up a lambda, calls, translate, strips...
  471.       TR-LAMBDA
  472.       ;; translate only a standard lambda expression
  473.       )
  474.   
  475.   (*EXPR FREE-LISP-VARS
  476.      PUSH-DEFVAR
  477.      TR-TRACE-EXIT
  478.      TR-TRACE-ENTRY
  479.      side-effect-free-check
  480.      tbound-free-vars)
  481.   
  482.   (*EXPR TRANSLATE-FUNCTION TR-MFUN DCONVX)
  483.   
  484.   ;; these special declarations are for before DEFMVAR
  485.   (SPECIAL $ERREXP $LOADPRINT $NUMER $SAVEDEF $NOLABELS $FUNCTIONS $PROPS 
  486.        $FILENAME $FILENUM $DIREC $DEVICE MUNBOUND $VALUES $TRANSRUN
  487.        ST OLDST  $VERSION
  488.        REPHRASE $PACKAGEFILE
  489.        DSKFNP)
  490.   
  491.   ;; end of COMPLR declarations section.
  492.   )
  493.  
  494. (defmacro bind-transl-state (&rest forms)
  495.   ;; this binds all transl state variables to NIL.
  496.   ;; and binds user-settable variables to themselves.
  497.   ;; $TRANSCOMPILE for example can be set to TRUE while translating
  498.   ;; a file, yet will only affect that file.
  499.   ;; Called in 3 places, for compactness maybe this should be a PROGV
  500.   ;; which references a list of variables?
  501.   `(let (*WARNED-UN-DECLARED-VARS*
  502.      *WARNED-FEXPRS* 
  503.      *WARNED-MODE-VARS*
  504.      *WARNED-UNDEFINED-VARS*
  505.      WARNED-UNDEFINED-VARIABLES
  506.      TR-ABORT
  507.      TRANSL-FILE
  508.      *IN-COMPFILE*
  509.      *IN-TRANSLATE-FILE*
  510.      *IN-TRANSLATE*
  511.      *PRE-TRANSL-FORMS* 
  512.      *NEW-AUTOLOAD-ENTRIES*
  513.      ($TR_SEMICOMPILE $TR_SEMICOMPILE)
  514.      (ARRAYS NIL)
  515.      (EXPRS NIL)
  516.      (LEXPRS NIL)
  517.      (FEXPRS NIL)
  518.      (SPECIALS NIL)
  519.      (DECLARES NIL)
  520.      ($TRANSCOMPILE $TRANSCOMPILE)
  521.      ($TR_NUMER $TR_NUMER)
  522.      DEFINED_VARIABLES)
  523.      ,@FORMS))
  524.  
  525.  
  526.  
  527. #-(or cl Multics)
  528. (DEFMACRO TR-FORMAT (STRING &REST ARGL)
  529.   `(MFORMAT *TRANSLATION-MSGS-FILES*
  530.         ,STRING ,@ARGL))
  531.  
  532. ;;; Is MFORMAT really prepared in general to handle
  533. ;;; the above form. Certainly not on Multics.
  534. #+(and Multics (not cl))
  535. (defmacro tr-format (string &rest argl)
  536.   `(cond ((consp *translation-msgs-files*)
  537.       (mapcar #'(lambda (file)
  538.              (mformat file ,string ,@argl))
  539.           *translation-msgs-files*))
  540.      (t (mformat *translation-msgs-files* ,string ,@argl))))
  541.  
  542. #+cl
  543. (defun tr-format (sstring &rest argl &aux strs)
  544.   (cond ((consp *translation-msgs-files*)(setq strs *translation-msgs-files*))
  545.     (t (setq strs (list *translation-msgs-files*))))
  546.   (sloop for v in strs
  547.     do (apply 'mformat v sstring argl)))
  548.  
  549.  
  550. ;;; for debugging convenience:
  551. ;;(DEFMACRO TR (EXP) `(BIND-TRANSL-STATE (TRANSLATE ,EXP)))
  552.  
  553. ;; to use in mixing maxima and lisp
  554. ;; (tr #$$f(x):=x+2$)
  555. (defmacro tr (u)
  556.  (and (consp u) (eq (car u) 'quote)
  557.   (BIND-TRANSL-STATE (translate-macexpr-toplevel  (second u)))))
  558.  
  559.  
  560. ;;; These are used by MDEFUN and MFUNCTION-CALL.
  561. ;;; N.B. this has arguments evaluated twice because I am too lazy to
  562. ;;; use a LET around things.
  563.  
  564. (DEFMACRO PUSH-INFO (NAME INFO STACK)
  565.   `(LET ((*INFO* (ASSQ ,NAME ,STACK)))
  566.      (COND (*INFO* ;;; should check for compatibility of INFO here.
  567.         )
  568.        (T
  569.         (PUSH (CONS ,NAME ,INFO) ,STACK)))))
  570.  
  571. (DEFMACRO GET-INFO (NAME STACK)
  572.   `(CDR (ASSQ ,NAME ,STACK)))
  573.  
  574. (DEFMACRO POP-INFO (NAME STACK)
  575.   `(LET ((*INFO* (ASSQ ,NAME ,STACK)))
  576.      (COND (*INFO*
  577.         (SETQ ,STACK (zl-DELETE *INFO* ,STACK))
  578.         (CDR *INFO*))
  579.        (T NIL))))
  580.  
  581. (DEFMACRO TOP-IND (STACK)
  582.   `(COND ((NULL ,STACK) NIL)
  583.      (T
  584.       (CAAR ,STACK))))
  585.  
  586.  
  587.  
  588.